home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 05 - 1989 / 05.09 Sep 89 / Data Editor Source / DataEdit.for < prev    next >
Encoding:
Text File  |  1988-08-26  |  11.1 KB  |  474 lines  |  [TEXT/EDIT]
  1. ******************************************************************
  2. *                                                                *
  3. *  Data Editor                                                   *
  4. *  © 1988 by Mark E. McBride                                     *
  5. *            1205 Dana Drive                                     *
  6. *            Oxford, OH  45056                                   *
  7. *                                                                *
  8. *  Developed using Absoft MacFortran/020 and FaceIt.             *
  9. *  Program provides a Mac user interface to which number         *
  10. *  crunching routines can easily be added.  Takes advantage      *
  11. *  of FaceIt's general event loop, standard Mac environment,     *
  12. *  sheet windows.                                                *
  13. *                                                                *
  14. ******************************************************************
  15.  
  16.       PROGRAM DataEdit
  17.     real*8 pt(1)
  18.     call main(pt)
  19.     end
  20.     
  21.     Subroutine main(pt)
  22.     implicit none
  23.  
  24. *  Absoft toolbox parameter equates, change pathname to reflect
  25. *  your disk setup.
  26.     include HD40:Fortran:Include Files:memory.inc
  27.     INTEGER PTR
  28.     PARAMETER (PTR=Z'C0000000')
  29.  
  30. *  Local variables
  31.     real*8 pt(*)
  32.       integer*4 toolbx,i,j,npt,PtPtr,PtHdl
  33.     integer*4 action,nmax,kmax
  34.     character*256 Head,saveMAC
  35.     logical*1 check
  36.     
  37.       include HD40:Fortran:FaceIt:StorMF.inc
  38.  
  39. *    load JumpMF     !!!REMOVE this line if JumpMF is linked to program!!!
  40. *    load toolbx  !!!REMOVE this line if toolbx is linked to program!!!
  41.  
  42.       name = 'DEdit.Rsrc'           !temporary resource file
  43.       call FaceIt(1,1,-1,50,1,2)    !initialize FaceIt
  44.  
  45. *  setup default array information
  46.     data nmax/100/
  47.     data kmax/2/
  48.     
  49. *  set initial sheet to 1x1 array so that open command
  50. *  is available, do not hide sheet
  51. *  sheet window must be active window to get open routine
  52. *  called for the sheet.
  53.     PtPtr=0                !pointer to pt array
  54.     PtHdl=0                !handle to pt array
  55.  
  56. * The use of "1" for the first argument of the SetSh1 command
  57. * indicates that we will support "Open", "Save As", and "Save"
  58. * for this sheet.
  59.     pt(0)=0
  60.     name='empty'
  61.     arrayptr(1) = toolbx(PTR,pt)
  62.     call FaceIt(1,SetSh1,1,1,0,-6)
  63.     call FaceIt(0,ShoSh1,RetCtl,0,0,0)
  64. *
  65. *  Set Means... menu off until an array has been tagged to
  66. *  the sheet.
  67. *
  68.       call UpdateMenu(menuhdl(5),PtPtr)
  69.       
  70.  
  71.  
  72. *  Main loop
  73.       do
  74.         call FaceIt(0,0,0,0,0,0)           !give control to user
  75.         
  76.       select case (MAC)
  77.       
  78.         case('About')
  79.           call FaceIt(0,OpnAlt,1009,0,0,0)  !open "About Data Editor" alert
  80.  
  81. *  The points can be loaded from a DEdit data file.  The data format
  82. *  consists of nmax, kmax, then the kmax string titles, finally, the data.
  83.         case('Open')
  84.           Head='opening sheet'
  85.         action=0
  86.         if (PtPtr<>0) then
  87.           call FaceIt(1,FixSh1,RetCtl,0,0,0)
  88.           call SaveIt(Head,action)
  89.         end if
  90.         if (action=1)
  91.      +        call SaveDa(pt,nmax*kmax,nmax,kmax)
  92.         MAC = 'DPTE'
  93.         if (action<3) call FaceIt(0,StdOpn,0,0,0,0)
  94.         if ((name<>'Cancel').and.(action<3)) then
  95.           if (PtPtr<>0)
  96.      +        call toolbx(DISPOSHANDLE,PtHdl)
  97.           open(3,file = name,status = 'old',
  98.      +                      form='unformatted')
  99.           read(3)nmax,kmax
  100.           I4=nmax*kmax*8
  101.           call FaceIt(0,NewBlk,0,0,0,0)
  102.           if (I4<>0) then
  103.             PtHdl=I4
  104.             PtPtr=long(I4)
  105.             call dynam(PtPtr)
  106.           else
  107.             MAC='Failed to allocate memory.'
  108.             call FaceIt(0,OpnAlt,1005,0,0,0)
  109.             stop
  110.           end if
  111.           do (i=1,nmax*kmax)
  112.             pt(i)=0
  113.           repeat
  114.           do (i=1,kmax)
  115.             read(3)Head
  116.             MAC=trim(Head)
  117.             call FaceIt(0,SetStr,1001,i,0,0)
  118.           repeat
  119.           read(3)(pt(i),i=1,nmax*kmax)
  120.           close(3)
  121.           arrayptr(1) = toolbx(PTR,pt)
  122.           call FaceIt(1,SetSh1,nmax,kmax,0,-6)
  123.           fixrect(1)=1;fixrect(2)=1;
  124.           fixrect(3)=nmax;fixrect(4)=kmax;
  125.           call FaceIt(1,FixSh1,0,0,0,0)
  126.         end if
  127.         
  128. * We also support the saving of points back to disk...
  129.         case('Save As','Save')
  130.           if (MAC='Save As') name=''
  131.         call SaveDa(pt,nmax*kmax,nmax,kmax)
  132.           
  133. * Create a new array and tag it to the sheet window
  134.         case('New Sheet')
  135.           Head='setting new sheet'
  136.         action=0
  137.         if (PtPtr<>0) then
  138.           call FaceIt(1,FixSh1,RetCtl,0,0,0)
  139.           call SaveIt(Head,action)
  140.         end if
  141.         if (action=1)
  142.      +        call SaveDa(pt,nmax*kmax,nmax,kmax)
  143.         check=.false.
  144.         if (action<3) call NewDlg(nmax,kmax,check)
  145.         if ((check).and.(action<3)) then 
  146.             if (PtPtr<>0)
  147.      +            call toolbx(DISPOSHANDLE,PtHdl)
  148.           I4=nmax*kmax*8
  149.           call FaceIt(0,NewBlk,0,0,0,0)
  150.           if (I4<>0) then
  151.             PtHdl=I4
  152.             PtPtr=long(I4)
  153.             call dynam(PtPtr)
  154.           else
  155.             MAC='Failed to allocate memory.'
  156.             call FaceIt(0,OpnAlt,1005,0,0,0)
  157.             stop
  158.           end if
  159.           do (i=1,nmax*kmax)
  160.             pt(i)=0
  161.           repeat
  162.           name=''
  163.           do (i=1,kmax)
  164.             I4=i
  165.             call FaceIt(0,I4ToS,0,0,0,0)
  166.             MAC='X'//trim(MAC)
  167.             call FaceIt(0,SetStr,1001,i,0,0)
  168.           repeat
  169.           arrayptr(1) = toolbx(PTR,pt)
  170.           call FaceIt(1,SetSh1,nmax,kmax,0,-6)
  171.           fixrect(1)=1;fixrect(2)=1;
  172.           fixrect(3)=nmax;fixrect(4)=kmax;
  173.           call FaceIt(1,FixSh1,0,0,0,0)
  174.         end if
  175.  
  176.         case('Quit','Transfer')
  177.           saveMAC=MAC
  178.         if (MAC='Quit')Head='Quitting'
  179.         if (MAC='Transfer')Head='Transferring'
  180.         action=0
  181.         if (PtPtr<>0) then
  182.           call FaceIt(1,FixSh1,RetCtl,0,0,0)
  183.           call SaveIt(Head,action)
  184.         end if
  185.         if (action=1)
  186.      +        call SaveDa(pt,nmax*kmax,nmax,kmax)
  187.         if (action<3) then
  188.           if (saveMAC='Quit') then
  189.             call FaceIt(0,DoQuit,0,0,0,0)      !complete Quit
  190.           else if (saveMAC='Transfer') then
  191.             call FaceIt(0,DoTran,0,0,0,0)      !complete Transfer
  192.           end if
  193.         end if
  194.  
  195.         case('Means...')
  196.           call Means(pt,nmax,kmax)
  197.         
  198.         case default
  199.       
  200.       end select
  201.  
  202.       call UpdateMenu(menuhdl(5),PtPtr)
  203.       
  204.       
  205.     repeat
  206.  
  207.       end
  208.  
  209.  
  210. *
  211. * The following menu-updating routine keeps a single menu item
  212. * updated.
  213. *
  214.     SUBROUTINE UpdateMenu(amenuhdl,aPtr)
  215.     implicit none
  216.       INTEGER ENABLEITEM
  217.       PARAMETER (ENABLEITEM=Z'93911000')
  218.     INTEGER DISABLEITEM
  219.     PARAMETER (DISABLEITEM=Z'93A11000')
  220.     integer*4 amenuhdl,aPtr
  221.     if (aPtr<>0) then                !data in array
  222.       call toolbx(ENABLEITEM,amenuhdl,1)
  223.     else
  224.       call toolbx(DISABLEITEM,amenuhdl,1)
  225.     end if
  226.     end
  227.  
  228. *
  229. *  Write data to output file
  230. *
  231.     Subroutine SaveDa(pt,npts,nmax,kmax)
  232.     implicit none
  233.  
  234.       real*8 pt(npts)
  235.     integer*4 i,npts,nmax,kmax
  236.     character*256 Head
  237.     
  238.       include HD40:Fortran:FaceIt:StorMF.inc
  239.     
  240.     if (trim(name)='') then
  241.       MAC = 'Save data points as'
  242.       call FaceIt(0,StdSav,0,0,0,0)
  243.     end if
  244.     if (name <> 'Cancel') then
  245.       open(3,file = name,status = 'new',form='unformatted')
  246.       write(3)nmax,kmax
  247.       do (i=1,kmax)
  248.         call FaceIt(0,GetStr,1001,i,0,0)
  249.         Head=trim(MAC)
  250.         write(3)Head
  251.       repeat
  252.       write(3)(pt(i),i=1,npts)
  253.       close(3)
  254.       call FaceIt(1,MovSh1,0,0,0,0)  !reset title
  255.       MAC = 'DPTE'
  256.       call FaceIt(0,SetTyp,RetCtl,0,0,0)
  257.       end if
  258.     
  259.     end
  260.  
  261. *
  262. *  The means subroutine calculates the means of the selected variables
  263. *  Over the selected observations
  264. *
  265.     Subroutine Means(pt,nmax,kmax)
  266.     
  267.     implicit none
  268.  
  269.     integer*4 nmax,kmax
  270.     real*8 pt(nmax,kmax),sum,xbar
  271.       integer*4 toolbx,i,j
  272.     integer*4 nbeg,nend,kbeg,kend
  273.     character*80 head(10),temp
  274.     logical*1 check
  275.  
  276.       include HD40:Fortran:FaceIt:StorMF.inc
  277.  
  278. *  call dialog to get observations and variables
  279.  
  280.     call SelObs(nbeg,nend,nmax,kmax,check)
  281.     
  282.     if (check) then
  283.  
  284. *  Write out headers, first select output window
  285. *  then write out information
  286.       
  287.       head(1)='Calculated Means'
  288.       head(2)=''
  289.       write(temp,'(i5)') nbeg
  290.       head(3)='Observations:  # '//trim(temp)
  291.       write(temp,'(i5)') nend
  292.       head(3)=trim(head(3))//' to # '//trim(temp)
  293.       head(4)=''
  294.       do (i=1,4)
  295.         MAC=head(i)
  296.         call FaceIt(-1,RetCtl,0,0,0,0)
  297.       repeat
  298.   
  299. *  Calculate Means and print out results
  300.  
  301.       kbeg=0
  302.       kend=0
  303.       do (j=1,kmax)
  304.         call FaceIt(0,GetStr,1001,j,0,0)
  305.         if (MAC(1:1)='*') then
  306.           if (kbeg=0) kbeg=j
  307.         if ((kend=0).or.(kbeg>0)) kend=j
  308.           sum=0
  309.         do (i=nbeg,nend)
  310.           sum=sum+pt(i,j)
  311.         repeat
  312.         xbar=sum/(nend-nbeg+1)
  313.         write(temp,'(f12.6)') xbar
  314.         call FaceIt(0,GetStr,1001,j,0,0)
  315.         MAC='Mean of '//trim(MAC(2:22))//'= '//trim(temp)
  316.         call FaceIt(-1,RetCtl,0,0,0,0)
  317.         end if
  318.       repeat
  319.       selrect1(1)=nbeg
  320.       selrect1(3)=nend
  321.       selrect1(2)=kbeg
  322.       selrect1(4)=kend
  323.       fixrect(1)=1;fixrect(2)=1;
  324.       fixrect(3)=nmax;fixrect(4)=kmax;
  325.       call FaceIt(0,FixSh1,0,0,0,0)
  326.     end if
  327.     do (j=1,kmax)
  328.       call FaceIt(0,GetStr,1001,j,0,0)
  329.       if (MAC(1:1)='*') then
  330.         MAC=MAC(2:len(trim(MAC)))
  331.         call FaceIt(0,SetStr,1001,j,0,0)
  332.       end if
  333.     repeat    
  334.     MAC=' '
  335.     call FaceIt(-1,RetCtl,0,0,0,0)
  336.     MAC=' '
  337.     call FaceIt(-1,RetCtl,0,0,0,0)
  338.     
  339.     end
  340.  
  341.  
  342. *
  343. *  Set bounds for a new sheet
  344. *
  345.     subroutine NewDlg(nmax,kmax,check)
  346.  
  347.     implicit none
  348.  
  349.       integer*4 toolbx,i,nmax,kmax,avail
  350.     integer*2 mydialog(7)
  351.     logical*1 check
  352.     character*256 oldname
  353.     
  354. *  Absoft toolbox parameter equates, change pathname for your setup
  355.     include HD40:Fortran:Include Files:memory.inc
  356.  
  357.       include HD40:Fortran:FaceIt:StorMF.inc
  358.  
  359.     save mydialog
  360.     
  361.     data mydialog/0,0,-2,0,-2,0,-2/
  362.  
  363.     oldname=name
  364.     write(name,10) nmax,kmax
  365. 10    format(2i8)
  366.     do (i = 1,7)
  367.       dialog(i) = mydialog(i)
  368.     repeat
  369.     check=.false.
  370.     avail=toolbx(COMPACTMEM,8000000)
  371.     while (check<>.true.)
  372.       call FaceIt(0,OpnDlg,1010,0,0,0)      !open dialog #1010
  373.       if (dialog(1) = 1) then
  374.         read(name,12) nmax,kmax
  375. 12        format(2i8)
  376.         if (nmax*kmax*8>avail-20000) then
  377.           write(MAC,*)'Not enough memory. ',
  378.      +      (avail-20000)/8,' cells available.  ',
  379.      +      'Click to continue.'
  380.         call FaceIt(0,OpnAlt,1005,0,0,0)
  381.         else
  382.           check=.true.
  383.         do (i = 1,7)                       !update all values
  384.           mydialog(i) = dialog(i)
  385.         repeat
  386.         end if
  387.       else if (dialog(2)=1) then
  388.         check=.false.
  389.         call FaceIt(0,RetCtl,0,0,0,0)        !close dialog window
  390.         name=oldname
  391.         return
  392.       end if
  393.     repeat
  394.     call FaceIt(0,RetCtl,0,0,0,0)        !close dialog window
  395.     
  396.     end
  397.  
  398.  
  399. *
  400. *  Set observations to perform means on
  401. *
  402.     subroutine SelObs(nbeg,nend,nmax,kmax,check)
  403.  
  404.     implicit none
  405.  
  406.       integer*4 nbeg,nend,nmax,kmax
  407.     integer*4 toolbx,i,j
  408.     integer*2 mydialog(8)
  409.     logical*1 check
  410.     character*256 oldname
  411.     
  412.       include HD40:Fortran:FaceIt:StorMF.inc
  413.  
  414.      data mydialog/0,0,-2,0,-2,0,-2,0/
  415.  
  416.     oldname=name
  417.     write(name,10) selrect1(1),selrect1(3)
  418. 10    format(2i8)
  419.     do (j=selrect1(2),selrect1(4))
  420.       call FaceIt(0,GetStr,1001,j,0,0)
  421.       MAC='*'//trim(MAC)
  422.       call FaceIt(0,SetStr,1001,j,0,0)
  423.     repeat
  424.     do (i = 1,8)
  425.       dialog(i) = mydialog(i)
  426.     repeat
  427.     listID(1)=-1001
  428.     check=.false.
  429.     while (check<>.true.)
  430.       call FaceIt(0,OpnDlg,1020,0,0,0)         !open dialog #1020
  431.       if (dialog(1) = 1) then
  432.         read(name,12) nbeg,nend
  433. 12        format(2i8)
  434.       if (nend>nmax) nend=nmax
  435.         do (i = 1,8)                          !update all values
  436.         mydialog(i) = dialog(i)
  437.         repeat
  438.         check=.true.
  439.       else if (dialog(2)=1) then
  440.         call FaceIt(0,RetCtl,0,0,0,0)        !close dialog window
  441.         check=.false.
  442.         name=oldname
  443.         return
  444.       end if
  445.     repeat
  446.     name=oldname
  447.  
  448.     call FaceIt(0,RetCtl,0,0,0,0)              !close dialog window
  449.     
  450.     end
  451.  
  452.  
  453. *
  454. *  check whether to save Data before opening
  455. *
  456.     subroutine SaveIt(what,action)
  457.  
  458.     implicit none
  459.  
  460.     integer*4 action
  461.     character*256 what
  462.     
  463.       include HD40:Fortran:FaceIt:StorMF.inc
  464.  
  465.     write(MAC,'(2a64)')trim(name),trim(what)
  466.     call FaceIt(0,OpnAlt,1030,0,0,0)
  467.     action=dialog(1)
  468.     
  469.  
  470.     end
  471.  
  472.  
  473.       include HD40:Fortran:FaceIt:FaceMF.inc
  474.